home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacGambit 2.0 / sources2 / Thomas / compiler.scm < prev    next >
Encoding:
Text File  |  1992-11-25  |  32.5 KB  |  771 lines  |  [TEXT/gamI]
  1. tware agree to the terms and conditions set forth herein,
  2. ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
  3. ;* right and license under any changes, enhancements or extensions made to the
  4. ;* core functions of the software, including but not limited to those affording
  5. ;* compatibility with other hardware or software environments, but excluding
  6. ;* applications which incorporate this software.  Users further agree to use
  7. ;* their best efforts to return to Digital any such changes, enhancements or
  8. ;* extensions that they make and inform Digital of noteworthy uses of this
  9. ;* software.  Correspondence should be provided to Digital at:
  10. ;* 
  11. ;*            Director, Cambridge Research Lab
  12. ;*            Digital Equipment Corp
  13. ;*            One Kendall Square, Bldg 700
  14. ;*            Cambridge MA 02139
  15. ;* 
  16. ;* This software may be distributed (but not offered for sale or transferred
  17. ;* for compensation) to third parties, provided such third parties agree to
  18. ;* abide by the terms and conditions of this notice.
  19. ;* 
  20. ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
  21. ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
  22. ;* MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
  23. ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
  24. ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
  25. ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
  26. ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  27. ;* SOFTWARE.
  28.  
  29. ; $Id: compiler.scm,v 1.26 1992/09/11 21:24:20 jmiller Exp $
  30.  
  31. ;;;; This file contains the Thomas -> Scheme compiler and
  32. ;;;; routines needed ONLY at compilation time.  Support routines that
  33. ;;;; are also needed when Dylan programs run are located in generic.scm
  34. ;;;; (generic operator dispatch), class.scm (class heterarchy), and
  35. ;;;; support.scm (general support routines)
  36.  
  37. ;;; Normal external entry points for compilation
  38.  
  39. (define (compile-expression e multi-value mod-vars continue)
  40.   ;; e is a single Thomas expression
  41.   ;; multi-value is an expression to be passed as the multi-value
  42.   ;;  vector (or #F) at runtime
  43.   ;; mod-vars is a list of pre-existing module variables
  44.   ;; continue is a function that receives:
  45.   ;;   a: the output code
  46.   ;;   b: the preamble (def'ns of free variables, refs, sets)
  47.   ;;   c: the list of newly created module variables
  48.   (define (define-module-variable name)
  49.     `(DEFINE ,name ',the-unassigned-value))
  50.   (define (define-module-getter name)
  51.     `(DEFINE (,(name->module-getter name)) ,name))
  52.   (define (define-module-setter name)
  53.     `(DEFINE (,(name->module-setter name) NEW-VALUE)
  54.        (SET! ,name NEW-VALUE)))
  55.   (really-compile e mod-vars '() multi-value
  56.    (lambda (compiled-output free-vars)
  57.      (let* ((need-getter/setters
  58.          (if (null? free-vars)
  59.          '()
  60.          (set-difference free-vars mod-vars member)))
  61.         (need-definition
  62.          (set-difference need-getter/setters
  63.                  dylan::predefined-variables member)))
  64.        (continue need-definition
  65.          `(,@(map define-module-variable need-definition)
  66.            ,@(map define-module-getter need-getter/setters)
  67.            ,@(map define-module-setter need-getter/setters))
  68.          compiled-output)))))
  69.  
  70. (define dylan::scheme-names-of-predefined-names
  71.   `((* dylan:*)                        ; Method
  72.     (+ dylan:+)                        ; Method
  73.     (- dylan:-)                        ; Method
  74.     (/ dylan:/)                        ; Method
  75.     (/= dylan:/=)                    ; Method
  76.     (< dylan:<)                        ; Method
  77.     (<= dylan:<=)                    ; Method
  78.     (<abort> <abort>)                    ; Class
  79.     (<array> <array>)                    ; Class
  80.     (<byte-string> <byte-string>)            ; Class
  81.     (<character> <character>)                ; Class
  82.     (<class> <class>)                    ; Class
  83.     (<collection> <collection>)                ; Class
  84.     (<complex> <complex>)                ; Class
  85.     (<condition> <condition>)                ; Class
  86.     (<deque> <deque>)                    ; Class
  87.     (<double-float> <double-float>)            ; Class
  88.     (<empty-list> <empty-list>)                ; Class
  89.     (<error> <error>)                    ; Class
  90.     (<explicit-key-collection>                ; Class
  91.      <explicit-key-collection>)
  92.     (<extended-float> <extended-float>)            ; Class
  93.     (<float> <float>)                    ; Class
  94.     (<function> <function>)                ; Class
  95.     (<generic-function> <generic-function>)        ; Class
  96.     (<integer> <integer>)                ; Class
  97.     (<keyword> <keyword>)                ; Class
  98.     (<list> <list>)                    ; Class
  99.     (<method> <method>)                    ; Class
  100.     (<mutable-collection> <mutable-collection>)        ; Class
  101.     (<mutable-explicit-key-collection>            ; Class
  102.      <mutable-explicit-key-collection>)
  103.     (<mutable-sequence> <mutable-sequence>)         ; Class
  104.     (<number> <number>)                    ; Class
  105.     (<object> <object>)                    ; Class
  106.     (<pair> <pair>)                    ; Class
  107.     (<range> <range>)                    ; Class
  108.     (<ratio> <ratio>)                    ; Class
  109.     (<rational> <rational>)                ; Class
  110.     (<real> <real>)                    ; Class
  111.     (<rectangular-complex> <rectangular-complex>)   ; Class
  112.     (<restart> <restart>)                ; Class
  113.     (<sequence> <sequence>)                ; Class
  114.     (<serious-condition> <serious-condition>)        ; Class
  115.     (<simple-error> <simple-error>)            ; Class
  116.     (<simple-object-vector> <simple-object-vector>) ; Class
  117.     (<simple-restart> <simple-restart>)            ; Class
  118.     (<simple-warning> <simple-warning>)            ; Class
  119.     (<single-float> <single-float>)            ; Class
  120.     (<singleton> <singleton>)                ; Class
  121.     (<slot-descriptor> <slot-descriptor>)        ; Class
  122.     (<stretchy-vector> <stretchy-vector>)        ; Class
  123.     (<string> <string>)                    ; Class
  124.     (<symbol> <symbol>)                    ; Class
  125.     (<table> <table>)                    ; Class
  126.     (<type-error> <type-error>)                ; Class
  127.     (<unicode-string> <unicode-string>)            ; Class
  128.     (<vector> <vector>)                    ; Class
  129.     (<warning> <warning>)                ; Class
  130.     (= dylan:=)                        ; Method
  131.     (=hash dylan:=hash)                    ; Generic-Function
  132.     (> dylan:>)                        ; Method
  133.     (>= dylan:>=)                    ; Method
  134.     (Id? dylan:id?)                    ; Method
  135.     (abort dylan:abort)                    ; Sealed-Function
  136.     (abs dylan:abs)                    ; Generic-Function
  137.     (acos dylan:acos)                    ; Generic-Function
  138.     (acosh dylan:acosh)                    ; Generic-Function
  139.     (add dylan:add)                    ; Generic-Function
  140.     (add! dylan:add!)                    ; G.F. Method
  141.     (add-method dylan:add-method)            ; Generic-Function
  142.     (add-new dylan:add-new)                ; Generic-Function
  143.     (add-new! dylan:add-new!)                ; Generic-Function
  144.     (add-slot dylan:add-slot)                ; Generic-Function
  145.     (all-superclasses dylan:all-superclasses)       ; Generic-Function
  146.     (always dylan:always)                ; Method
  147.     (angle dylan:angle)                    ; Generic-Method
  148.     (any? dylan:any?)                    ; Generic-Function
  149.     (append dylan:append)                ; Generic-Function
  150.     (applicable-method? dylan:applicable-method?)   ; Generic-Function
  151.     (apply dylan:apply)                    ; Function
  152.     (aref dylan:aref)                    ; Generic-Function
  153.     (as dylan:as)                    ; Generic-Function
  154.     (as-lowercase dylan:as-lowercase)                ; G.F. Method
  155.     (as-lowercase! dylan:as-lowercase!)            ; G.F. Method
  156.     (as-uppercase dylan:as-uppercase)            ; G.F. Method
  157.     (as-uppercase! dylan:as-uppercase!)            ; G.F. Method
  158.     (ash dylan:ash)                    ; Generic-Method
  159.     (asin dylan:asin)                    ; Generic-Function
  160.     (asinh dylan:asinh)                    ; Generic-Function
  161.     (atan dylan:atan)                    ; Generic-Function
  162.     (atan2 dylan:atan2)                    ; Generic-Function
  163.     (atanh dylan:atanh)                    ; Generic-Function
  164.     (binary* dylan:binary*)                ; Generic-Function
  165.     (binary+ dylan:binary+)                ; Generic-Function
  166.     (binary- dylan:binary-)                ; Generic-Function
  167.     (binary-gcd dylan:binary-gcd)            ; Generic-Method
  168.     (binary-lcm dylan:binary-lcm)            ; Generic-Method
  169.     (binary/ dylan:binary/)                ; Generic-Function
  170.     (binary< dylan:binary<)                ; Generic-Function
  171.     (binary= dylan:binary=)                ; Generic-Function
  172.     (break dylan:break)                    ; Sealed-Function
  173.     (caaar dylan:caaar)                    ; Method
  174.     (caadr dylan:caadr)                    ; Method
  175.     (caar dylan:caar)                    ; Method
  176.     (cadar dylan:cadar)                    ; Method
  177.     (caddr dylan:caddr)                    ; Method
  178.     (cadr dylan:cadr)                    ; Method
  179.     (car dylan:car)                    ; Method
  180.     (cdaar dylan:cdaar)                    ; Method
  181.     (cdadr dylan:cdadr)                    ; Method
  182.     (cdar dylan:cdar)                    ; Method
  183.     (cddar dylan:cddar)                    ; Method
  184.     (cdddr dylan:cdddr)                    ; Method
  185.     (cddr dylan:cddr)                    ; Method
  186.     (cdr dylan:cdr)                    ; Method
  187.     (ceiling dylan:ceiling)                ; Generic-Function
  188.     (ceiling/ dylan:ceiling/)                ; Generic-Function
  189.     (cerror dylan:cerror)                ; Sealed-Function
  190.     (check-type dylan:check-type)            ; Sealed-Function
  191.     (choose dylan:choose)                ; Generic-Function
  192.     (choose-by dylan:choose-by)                ; Generic-Function
  193.     (class-for-copy dylan:class-for-copy)           ; Generic-Function
  194.     (complement dylan:complement)            ; Method
  195.     (compose dylan:compose)                ; Method
  196.     (concatenate dylan:concatenate)            ; Generic-Function
  197.     (concatenate-as dylan:concatenate-as)        ; Generic-Function
  198.     (conjoin dylan:conjoin)                ; Method
  199.     (cons dylan:cons)                    ; Method
  200.     (copy-sequence dylan:copy-sequence)            ; Generic-Function
  201.     (copy-state dylan:copy-state)            ; Generic-Function
  202.     (cos dylan:cos)                    ; Generic-Function
  203.     (cosh dylan:cosh)                    ; Generic-Function
  204.     (current-element dylan:current-element)        ; Generic-Function
  205.     (current-key dylan:current-key)            ; Generic-Function
  206.     (curry dylan:curry)                    ; Method
  207.     (default-handler dylan:default-handler)        ; Generic-Function
  208.     (denominator dylan:denominator)            ; Generic-Method
  209.     (dimensions dylan:dimensions)            ; Generic-Function
  210.     (direct-subclasses dylan:direct-subclasses)        ; Generic-Function
  211.     (direct-superclasses dylan:direct-superclasses) ; Generic-Function
  212.     (disjoin dylan:disjoin)                ; Method
  213.     (do dylan:do)                        ; Generic-Function
  214.     (do-handlers dylan:do-handlers)            ; Sealed-Function
  215.     (element dylan:element)                ; Generic-Function
  216.     (empty? dylan:empty?)                ; Generic-Function
  217.     (error dylan:error)                        ; Sealed-Function
  218.     (even? dylan:even?)                    ; Generic-Function
  219.     (every? dylan:every?)                ; Generic-Function
  220.     (exp dylan:exp)                    ; Generic-Function
  221.     (expt dylan:expt)                    ; Generic-Function
  222.     (fill! dylan:fill!)                    ; Generic-Function
  223.     (final-state dylan:final-state)            ; G.F. Method
  224.     (find-key dylan:find-key)                ; Generic-Function
  225.     (find-method dylan:find-method)            ; Generic-Function
  226.     (find-pair dylan:find-pair)                ; Generic-Function
  227.     (first dylan:first)                    ; Generic-Function
  228.     (floor dylan:floor)                    ; Generic-Function
  229.     (floor/ dylan:floor/)                ; Generic-Function
  230.     (freeze-methods dylan:freeze-methods)        ; Generic-Function
  231.     (function-arguments dylan:function-arguments)   ; Generic-Function
  232.     (gcd dylan:gcd)                    ; Method
  233.     (generic-function-methods                ; Generic-Function
  234.      dylan:generic-function-methods)
  235.     (identity dylan:identity)                ; Method
  236.     (imag-part dylan:imag-part)                ; Generic-Method
  237.     (init-function dylan:init-function)            ; Generic-Function
  238.     (init-keyword dylan:init-keyword)            ; Generic-Function
  239.     (init-value dylan:init-value)            ; Generic-Function
  240.     (initial-state dylan:initial-state)            ; Generic-Function
  241.     (initialize dylan:initialize)            ; Generic-Function
  242.     (instance? dylan:instance?)                ; Generic-Function
  243.     (integral? dylan:integral?)                ; Generic-Function
  244.     (intersection dylan:intersection)            ; Generic-Function
  245.     (key-sequence dylan:key-sequence)            ; Generic-Function
  246.     (last dylan:last)                    ; Generic-Function
  247.     (lcm dylan:lcm)                    ; Method
  248.     (list dylan:list)                    ; Method
  249.     (list* dylan:list*)                    ; Method
  250.     (log dylan:log)                    ; Generic-Function
  251.     (logand dylan:logand)                ; Generic-Method
  252.     (logandc1 dylan:logandc1)                ; Generic-Method
  253.     (logandc2 dylan:logandc2)                ; Generic-Method
  254.     (logbit? dylan:logbit?)                ; Generic-Method
  255.     (logeqv dylan:logeqv)                ; Generic-Method
  256.     (logior dylan:logior)                ; Generic-Method
  257.     (lognand dylan:lognand)                ; Generic-Method
  258.     (lognor dylan:lognor)                ; Generic-Method
  259.     (lognot dylan:lognot)                ; Generic-Method
  260.     (logorc1 dylan:logorc1)                ; Generic-Method
  261.     (logorc2 dylan:logorc2)                ; Generic-Method
  262.     (logxor dylan:logxor)                ; Generic-Method
  263.     (make dylan:make)                    ; Generic-Function
  264.     (make-polar dylan:make-polar)            ; Generic-Function
  265.     (make-read-only dylan:make-read-only)        ; Generic-Function
  266.     (make-rectangular dylan:make-rectangular)        ; Generic-Function
  267.     (map dylan:map)                    ; Generic-Function
  268.     (map-as dylan:map-as)                ; Generic-Function
  269.     (map-into dylan:map-into)                ; Generic-Function
  270.     (max dylan:max)                    ; Method
  271.     (member? dylan:member?)                ; Generic-Function
  272.     (method-specializers dylan:method-specializers) ; Generic-Function
  273.     (min dylan:min)                    ; Method
  274.     (modulo dylan:modulo)                ; Generic-Function
  275.     (negative? dylan:negative?)                ; Generic-Function
  276.     (next-state dylan:next-state)            ; Generic-Function
  277.     (not dylan:not)                    ; Function
  278.     (numerator dylan:numerator)                ; Generic-Method
  279.     (object-class dylan:object-class)            ; Generic-Function
  280.     (odd? dylan:odd?)                    ; Generic-Function
  281.     (pop dylan:pop)                    ; Generic-Function
  282.     (pop-last dylan:pop-last)                ; Generic-Function
  283.     (positive? dylan:positive?)                ; Generic-Function
  284.     (previous-state dylan:previous-state)        ; G.F. Method
  285.     (push dylan:push)                    ; Generic-Function
  286.     (push-last dylan:push-last)                ; Generic-Function
  287.     (range dylan:range)                    ; Generic-Function
  288.     (rcurry dylan:rcurry)                ; Method
  289.     (real-part dylan:real-part)                ; Generic-Method
  290.     (rationalize dylan:rationalize)            ; Generic-Method
  291.     (reduce dylan:reduce)                ; Generic-Function
  292.     (reduce1 dylan:reduce1)                ; Generic-Function
  293.     (remainder dylan:remainder)                ; Generic-Function
  294.     (remove dylan:remove)                ; Generic-Function
  295.     (remove! dylan:remove!)                ; Generic-Function
  296.     (remove-duplicates dylan:remove-duplicates)        ; Generic-Function
  297.     (remove-duplicates! dylan:remove-duplicates!)   ; Generic-Function
  298.     (remove-key! dylan:remove-key!)            ; Generic-Function
  299.     (remove-method dylan:remove-method)            ; Generic-Function
  300.     (remove-slot dylan:remove-slot)            ; Generic-Function
  301.     (replace-elements! dylan:replace-elements!)        ; Generic-Function
  302.     (replace-subsequence! dylan:replace-subsequence!) ; Generic-Function
  303.     (restart-query dylan:restart-query)            ; Generic-Function
  304.     (return-allowed? dylan:return-allowed?)        ; Generic-Function
  305.     (return-description dylan:return-description)   ; Generic-Function
  306.     (return-query dylan:return-query)            ; Generic-Function
  307.     (reverse dylan:reverse)                ; Generic-Function
  308.     (reverse! dylan:reverse!)                ; Generic-Function
  309.     (round dylan:round)                    ; Generic-Function
  310.     (round/ dylan:round/)                ; Generic-Function
  311.     (seal dylan:seal)                    ; Generic-Function
  312.     (second dylan:second)                ; Generic-Function
  313.     (shallow-copy dylan:shallow-copy)            ; Generic-Function
  314.     (signal dylan:signal)                ; Sealed-Function
  315.     (sin dylan:sin)                    ; Generic-Function
  316.     (singleton dylan:singleton)                ; Function
  317.     (sinh dylan:sinh)                    ; Generic-Function
  318.     (size dylan:size)                    ; G.F. Method
  319.     (slot-allocation dylan:slot-allocation)        ; Generic-Function
  320.     (slot-descriptor dylan:slot-descriptor)        ; Generic-Function
  321.     (slot-descriptors dylan:slot-descriptors)       ; Generic-Function
  322.     (slot-getter dylan:slot-getter)            ; Generic-Function
  323.     (slot-initialized? dylan:slot-initialized?)        ; Generic-Function
  324.     (slot-setter dylan:slot-setter)            ; Generic-Function
  325.     (slot-type dylan:slot-type)                ; Generic-Function
  326.     (slot-value dylan:slot-value)            ; Generic-Function
  327.     (sort dylan:sort)                    ; Generic-Function
  328.     (sort! dylan:sort!)                    ; Generic-Function
  329.     (sorted-applicable-methods                ; Generic-Function
  330.      dylan:sorted-applicable-methods)
  331.     (sqrt dylan:sqrt)                    ; Generic-Method
  332.     (subclass? dylan:subclass?)                ; Generic-Function
  333.     (subsequence-position dylan:subsequence-position) ; Generic-Function
  334.     (tan dylan:tan)                    ; Generic-Function
  335.     (tanh dylan:tanh)                    ; Generic-Function
  336.     (third dylan:third)                    ; Generic-Function
  337.     (truncate dylan:truncate)                ; Generic-Function
  338.     (truncate/ dylan:truncate/)                ; Generic-Function
  339.     (unary- dylan:unary-)                ; Generic-Function
  340.     (unary/ dylan:unary/)                ; Generic-Function
  341.     (union dylan:union)                    ; Generic-Function
  342.     (values dylan:values)                ; Function
  343.     (vector dylan:vector)                ; Method
  344.     (zero? dylan:zero?)                    ; Generic-Function
  345.     ;;;;;;;;;;;;;;; SETTER VARIABLES
  346.     (,(name->setter 'slot-value) dylan:setter/slot-value/)
  347.     (,(name->setter 'element) dylan:setter/element/)
  348.     (,(name->setter 'current-element) dylan:setter/current-element/)
  349.     (,(name->setter 'first) dylan:setter/first/)
  350.     (,(name->setter 'second) dylan:setter/second/)
  351.     (,(name->setter 'third) dylan:setter/third/)
  352.     (,(name->setter 'aref) dylan:setter/aref/)
  353.     (,(name->setter 'car) dylan:setter/car/)
  354.     (,(name->setter 'cdr) dylan:setter/cdr/)
  355.     (,(name->setter 'caar) dylan:setter/caar/)
  356.     (,(name->setter 'cadr) dylan:setter/cadr/)
  357.     (,(name->setter 'cdar) dylan:setter/cdar/)
  358.     (,(name->setter 'cddr) dylan:setter/cddr/)
  359.     (,(name->setter 'caaar) dylan:setter/caaar/)
  360.     (,(name->setter 'caadr) dylan:setter/caadr/)
  361.     (,(name->setter 'cadar) dylan:setter/cadar/)
  362.     (,(name->setter 'caddr) dylan:setter/caddr/)
  363.     (,(name->setter 'cdaar) dylan:setter/cdaar/)
  364.     (,(name->setter 'cdadr) dylan:setter/cdadr/)
  365.     (,(name->setter 'cddar) dylan:setter/cddar/)
  366.     (,(name->setter 'cdddr) dylan:setter/cdddr/)
  367.     ;;;;;;;;;;;;;;; CRL ADDITIONS
  368.     (display dylan:display)
  369.     (newline dylan:newline)
  370.     (write-line dylan:write-line)
  371.     (print dylan:print)
  372.     ,@implementation-specific:additional-dylan-bindings
  373.     ))
  374.  
  375. (define dylan::predefined-names
  376.   (map car dylan::scheme-names-of-predefined-names))
  377.  
  378. (define dylan::predefined-variables
  379.   (map cadr dylan::scheme-names-of-predefined-names))
  380.  
  381. (define (thomas file-name . expressions)
  382.   (compile-expression `(BEGIN ,@expressions) #F '()
  383.     (lambda (new-vars preamble-code compiled)
  384.       new-vars                ; Not used
  385.       (with-output-to-file file-name
  386.     (lambda ()
  387.       (display "; Output generated by the CRL Thomas->Scheme compiler.")
  388.       (newline)
  389.       (implementation-specific:generate-file
  390.        expressions
  391.        `(dylan::catch-all-conditions
  392.          (lambda () ,@preamble-code ,compiled))))))))
  393.  
  394. (define (thomas->scheme input output)
  395.   (let ((in-port (open-input-file input)))
  396.     (let loop ((exprs '()))
  397.       (let ((next (read in-port)))
  398.     (if (eof-object? next)
  399.         (thomas output `(BEGIN ,@(reverse exprs)))
  400.         (loop (cons next exprs)))))))
  401.  
  402. ;;; Compile a list of forms, returning a list of Scheme expressions
  403. ;;; ASSUMPUTION: multiple-values?, if not #F, is to be used only for
  404. ;;; compiling the last of the forms.
  405.  
  406. (define (compile-forms
  407.      forms module-vars bound-vars really-compile
  408.      multiple-values? continue)
  409.   (let loop ((result '())
  410.          (forms forms)
  411.          (mod-vars module-vars))
  412.     (if (null? forms)
  413.     (continue (reverse result) mod-vars)
  414.     (really-compile (car forms) mod-vars bound-vars
  415.             (if (null? (cdr forms)) multiple-values? #F)
  416.       (lambda (compiled mod-vars)
  417.         (loop (cons compiled result)
  418.           (cdr forms)
  419.           mod-vars))))))
  420.  
  421. ;;; The real compiler.
  422. ;;;
  423. ;;; Input: e is a form to be compiled
  424. ;;;        module-vars are the module variables already known to exist
  425. ;;;        bound-vars are the names of lexically enclosing variables
  426. ;;;        multiple-values? is either #F, indicating that the current
  427. ;;;          expressions is being compiled in non-tail position or has
  428. ;;;          the name of an internal variable to be used at runtime to
  429. ;;;          transmit the multiple-value returning function along the
  430. ;;;          tail call chain.
  431. ;;;        continue is called with the result of the compilation, and
  432. ;;;          is passed the single SCHEME form resulting from compiling
  433. ;;;          e and the new list of module variables.
  434. ;;; Output: always either error exits or tail calls into continue
  435.  
  436. (define (really-compile e module-vars bound-vars
  437.             multiple-values? continue)
  438.   (cond
  439.    ((or (null? e) (boolean? e) (string? e)
  440.     (char? e) (number? e))        ; syntax might be an issue...
  441.     (continue e module-vars))
  442.    ((or (vector? e) (keyword? e))    ; Keywords self-evaluate in
  443.                     ; Dylan, but not in Scheme
  444.     (continue `(QUOTE ,e) module-vars))
  445.    ((variable-name? e)
  446.     ;; As in Scheme, but the compiler needs to distinguish  bound from
  447.     ;; free
  448.     (let* ((name (variable->name e))
  449.        (new-mod-vars (add-variable name bound-vars module-vars)))
  450.       (continue
  451.        (if (memq name new-mod-vars)
  452.        `(DYLAN::FREE-VARIABLE-REF ,name ',name)
  453.        name)
  454.        new-mod-vars)))
  455.    ((symbol? e)
  456.     (dylan::error "illegal Thomas variable" e))
  457.    ((and (pair? e) (assq (car e) compilation-functions)) =>
  458.     (lambda (binding)
  459.       (((cdr binding)) (cdr e) module-vars bound-vars
  460.                really-compile multiple-values? continue)))
  461.    ((and (list? e) (not (null? e)))
  462.     (compile-forms e module-vars bound-vars really-compile #F
  463.            (lambda (forms module-vars)
  464.              (continue
  465.               `(DYLAN::APPLY ,multiple-values?
  466.                      ,@(map (lambda (x) `(LAMBDA () ,x))
  467.                         forms))
  468.                    module-vars))))
  469.    (else
  470.     (dylan::error "ill-formed expression" e))))
  471.  
  472. (define compiled-sharp-f
  473.   (really-compile #F '() '() #F (lambda (compiled free)
  474.                   free    ; Ignored
  475.                   compiled)))
  476.  
  477. (define compilation-functions
  478.   `((AND            . ,(lambda () compile-AND-form))
  479.     (BEGIN          . ,(lambda () compile-BEGIN-form))
  480.     (BIND           . ,(lambda () compile-BIND-form))
  481.     (BIND-EXIT      . ,(lambda () compile-BIND-EXIT-form))
  482.     (BIND-METHODS   . ,(lambda () compile-BIND-METHODS-form))
  483.     (CASE           . ,(lambda () compile-CASE-form))
  484.     (COND           . ,(lambda () compile-COND-form))
  485.     (DEFINE         . ,(lambda () compile-DEFINE-form))
  486.     (DEFINE-CLASS   . ,(lambda () compile-DEFINE-CLASS-form))
  487.     (DEFINE-GENERIC-FUNCTION .
  488.       ,(lambda () compile-DEFINE-GENERIC-FUNCTION-form))
  489.     (DEFINE-METHOD  . ,(lambda () compile-DEFINE-METHOD-form))
  490.     (DEFINE-SLOT    . ,(lambda () compile-DEFINE-SLOT-form))
  491.     (DOTIMES        . ,(lambda () compile-DOTIMES-form))
  492.     (FOR            . ,(lambda () compile-FOR-form))
  493.     (FOR-EACH       . ,(lambda () compile-FOR-EACH-form))
  494.     (HANDLER-BIND   . ,(lambda () compile-HANDLER-BIND-form))
  495.     (HANDLER-CASE   . ,(lambda () compile-HANDLER-CASE-form))
  496.     (IF             . ,(lambda () compile-IF-form))
  497.     (METHOD         . ,(lambda () compile-METHOD-form))
  498.     (OR             . ,(lambda () compile-OR-form))
  499.     (QUOTE          . ,(lambda () compile-QUOTE-form))
  500.     (SELECT         . ,(lambda () compile-SELECT-form))
  501.     (SET!           . ,(lambda () compile-SET!-form))
  502.     (SETTER         . ,(lambda () compile-SETTER-form))
  503.     (UNLESS         . ,(lambda () compile-UNLESS-form))
  504.     (UNTIL          . ,(lambda () compile-UNTIL-form))
  505.     (UNWIND-PROTECT . ,(lambda () compile-UNWIND-PROTECT-form))
  506.     (WHEN           . ,(lambda () compile-WHEN-form))
  507.     (WHILE          . ,(lambda () compile-WHILE-form))))
  508.  
  509. (define (compile-AND-form forms module-vars bound-vars really-compile
  510.               multiple-values? continue)
  511.    (if (null? forms) (dylan::error "AND must have forms"))
  512.    (compile-forms
  513.     forms module-vars bound-vars really-compile multiple-values?
  514.     (lambda (code mod-vars) (continue `(AND ,@code) mod-vars))))
  515.  
  516. (define (compile-BEGIN-form forms module-vars bound-vars really-compile
  517.         multiple-values? continue)
  518.    (if (null? forms)
  519.        (continue compiled-sharp-f module-vars)
  520.        (compile-forms
  521.     forms module-vars bound-vars
  522.     really-compile multiple-values?
  523.     (lambda (compiled module-vars)
  524.       (continue `(BEGIN ,@compiled) module-vars)))))
  525.  
  526. ; compile-BIND-form in file comp-class
  527.  
  528. (define (compile-BIND-EXIT-form
  529.      forms module-vars bound-vars really-compile multiple-values?
  530.      continue)
  531.   (must-be-list-of-at-least-length forms 1 "BIND-EXIT form invalid")
  532.   (let ((var (car forms))
  533.     (forms (cdr forms)))
  534.     (must-be-list-of-length var 1 "BIND-EXIT bad variable")
  535.     (if (not (variable-name? (car var)))
  536.     (dylan::error "BIND-EXIT -- bad variable name" var forms))
  537.     (let ((name (variable->name (car var))))
  538.       (really-compile
  539.        `(BEGIN ,@forms)
  540.        module-vars (cons name bound-vars) multiple-values?
  541.        (lambda (body module-vars)
  542.      (continue
  543.       `(DYLAN::CALL/CC
  544.         (LAMBDA (!BIND-EXIT)
  545.           (LET ((,name
  546.              (LAMBDA (!MULTIPLE-VALUES !NEXT-METHOD . VALUES)
  547.                !MULTIPLE-VALUES !NEXT-METHOD
  548.                (!BIND-EXIT
  549.             (DYLAN::SCHEME-APPLY
  550.              DYLAN:VALUES ,multiple-values?
  551.              NEXT-METHOD:NOT-GENERIC
  552.              VALUES)))))
  553.         ,body)))
  554.       module-vars))))))
  555.  
  556. ; compile-BIND-METHODS-form in file comp-method.scm
  557. ; compile-CASE-form in file comp-sf
  558. ; compile-COND-form in file comp-sf
  559.  
  560. (define (compile-DEFINE-form
  561.      forms module-vars bound-vars really-compile
  562.      multiple-values? continue)
  563.   multiple-values?            ; No reductions
  564.   (must-be-list-of-length forms 2 "Bad DEFINE syntax")
  565.   (let ((name (car forms))
  566.     (value (cadr forms)))
  567.     (if (not (variable-name? name))
  568.     (dylan::error "bad DEFINE variable" forms))
  569.     (really-compile value
  570.       (add-module-variable (variable->name name) #F module-vars)
  571.       bound-vars #F
  572.       (lambda (compiled-value new-module-vars)
  573.     (continue
  574.      `(BEGIN
  575.         (,(name->module-setter name) ,compiled-value)
  576.         ',name)
  577.      new-module-vars)))))
  578.  
  579. ; compile-DEFINE-CLASS-form in file comp-class
  580. ; compile-DEFINE-GENERIC-FUNCTION-form in file comp-class
  581. ; compile-DEFINE-METHOD-form in file comp-method
  582. ; compile-DEFINE-SLOT-form in file comp-class
  583.  
  584. (define (compile-DOTIMES-form
  585.      forms module-vars bound-vars really-compile
  586.      multiple-values? continue)
  587.     (must-be-list-of-at-least-length forms 1 "DOTIMES: bad syntax")
  588.     (let ((v/c/r (car forms))
  589.       (forms (cdr forms)))
  590.       (must-be-list-of-at-least-length v/c/r 2
  591.        "DOTIMES: Bad var/count/result list")
  592.       (let ((var (car v/c/r))
  593.         (count-form (cadr v/c/r))
  594.         (result (if (pair? (cddr v/c/r)) (caddr v/c/r) #F)))
  595.     (if (not (variable-name? var))
  596.         (dylan::error "DOTIMES -- invalid variable" var forms))
  597.     (if (not (or (null? (cddr v/c/r))
  598.              (null? (cdddr v/c/r))))
  599.         (dylan::error "DOTIMES -- bad syntax"))
  600.     (let ((name (variable->name var)))
  601.       (compile-forms
  602.        forms module-vars (cons name bound-vars) really-compile #F
  603.        (lambda (body-forms module-vars)
  604.          (compile-forms
  605.           (list count-form result)
  606.           module-vars bound-vars really-compile multiple-values?
  607.           (lambda (c/r-code module-vars)
  608.         (continue
  609.          `(DYLAN::DOTIMES ,(car c/r-code)
  610.                   (LAMBDA () ,(cadr c/r-code))
  611.                   (LAMBDA (,name) ,@body-forms))
  612.          module-vars)))))))))
  613.  
  614. ; compile-FOR-form in file comp-sf
  615.  
  616. (define (compile-FOR-EACH-form
  617.      forms module-vars bound-vars really-compile
  618.      multiple-values? continue)
  619.     (must-be-list-of-at-least-length forms 2 "FOR-EACH: bad syntax")
  620.     (for-each
  621.      (lambda (binding)
  622.        (must-be-list-of-length binding 2 "FOR-EACH: bad binding"))
  623.      (car forms))
  624.     (let ((names (map car (car forms)))
  625.       (collections (map cadr (car forms)))
  626.       (end-test-and-return-vals (cadr forms))
  627.       (forms (cddr forms)))
  628.       (compile-forms
  629.        collections module-vars bound-vars really-compile #F
  630.        (lambda (compiled-collections module-vars)
  631.      (compile-forms
  632.       (if (null? end-test-and-return-vals)
  633.           '(#F)
  634.           end-test-and-return-vals)
  635.       module-vars
  636.       (append names bound-vars) really-compile multiple-values?
  637.       (lambda (compiled-et module-vars)
  638.         (compile-forms
  639.          forms module-vars (append names bound-vars)
  640.          really-compile #F
  641.          (lambda (compiled-forms module-vars)
  642.            (continue
  643.         `(DYLAN::FOR-EACH
  644.           (LAMBDA (!MULTIPLE-VALUES !DYLAN:NEXT-METHOD ,@names)
  645.             !MULTIPLE-VALUES    ; Ignored
  646.             !DYLAN:NEXT-METHOD    ; Ignored
  647.             ,(if (null? end-test-and-return-vals)
  648.              `(BEGIN ,@compiled-forms #F)
  649.              `(IF ,(car compiled-et)
  650.                   (DYLAN::LIST ,@(if (null? (cdr compiled-et))
  651.                          (list compiled-sharp-f)
  652.                          (cdr compiled-et)))
  653.                   (BEGIN ,@compiled-forms #F))))
  654.           ,@compiled-collections)
  655.         module-vars)))))))))
  656.  
  657. ; compile-HANDLER-BIND-form in file comp-exc
  658. ; compile-HANDLER-CASE-form in file comp-exc
  659.  
  660. (define (compile-IF-form forms module-vars bound-vars really-compile
  661.              multiple-values? continue)
  662.     (must-be-list-of-length forms 3 "IF: invalid syntax")
  663.     (let ((pred (car forms))
  664.       (conseq (cadr forms))
  665.       (alter (caddr forms)))
  666.       (really-compile pred module-vars bound-vars #F
  667.     (lambda (c-pred module-vars)
  668.       (really-compile conseq module-vars
  669.               bound-vars multiple-values?
  670.         (lambda (c-conseq module-vars)
  671.           (really-compile alter module-vars
  672.                   bound-vars multiple-values?
  673.             (lambda (c-alter module-vars)
  674.           (continue `(IF ,c-pred ,c-conseq ,c-alter)
  675.                 module-vars)))))))))
  676.  
  677. ; compile-METHOD-form in file comp-method
  678.  
  679. (define (compile-OR-form
  680.      forms module-vars bound-vars really-compile
  681.      multiple-values? continue)
  682.   (compile-forms
  683.    forms module-vars bound-vars really-compile multiple-values?
  684.    (lambda (code mod-vars)
  685.      (continue `(OR ,@code) mod-vars))))
  686.  
  687. (define (compile-QUOTE-form forms module-vars bound-vars really-compile
  688.          multiple-values? continue)
  689.   bound-vars really-compile multiple-values?
  690.   (must-be-list-of-length forms 1 "QUOTE: invalid syntax")
  691.   (continue `(QUOTE ,@forms) module-vars))
  692.  
  693. ; compile-SELECT-form in file comp-sf
  694. ; compile-SET!-form in file
  695.  
  696. (define (compile-SETTER-form forms module-vars bound-vars really-compile
  697.                  multiple-values? continue)
  698.   forms module-vars bound-vars really-compile
  699.   multiple-values? continue
  700.   (dylan::error "bad SETTER syntax" forms))
  701.  
  702. (define (compile-UNLESS-form
  703.      forms module-vars bound-vars
  704.      really-compile multiple-values? continue)
  705.   bound-vars                ; Ignored
  706.   (must-be-list-of-at-least-length forms 1 "UNLESS: bad syntax")
  707.   (compile-forms forms module-vars bound-vars really-compile
  708.          (if (null? (cdr forms)) #F multiple-values?)
  709.     (lambda (forms module-vars)
  710.       (continue
  711.        `(IF (DYLAN::NOT ,(car forms))
  712.         (BEGIN ,@(if (null? (cdr forms)) (list #F) (cdr forms)))
  713.         #F)
  714.        module-vars))))
  715.  
  716. (define (compile-UNTIL-form
  717.      forms module-vars bound-vars really-compile
  718.      multiple-values? continue)
  719.   multiple-values?
  720.   (must-be-list-of-at-least-length forms 2 "UNTIL: bad syntax")
  721.   (compile-forms forms module-vars bound-vars really-compile #F
  722.     (lambda (forms module-vars)
  723.       (continue
  724.        `(DYLAN::WHILE (LAMBDA () (DYLAN::NOT ,(car forms)))
  725.               (LAMBDA () ,@(if (null? (cdr forms))
  726.                        (list #F)
  727.                        (cdr forms))))
  728.        module-vars))))
  729.  
  730. (define (compile-UNWIND-PROTECT-form
  731.      forms module-vars bound-vars really-compile
  732.      multiple-values? continue)
  733.   (must-be-list-of-at-least-length forms 1 "UNWIND-PROTECT: bad syntax")
  734.   (really-compile (car forms) module-vars bound-vars multiple-values?
  735.     (lambda (c-protect module-vars)
  736.       (really-compile `(BEGIN ,@(cdr forms))
  737.               module-vars bound-vars #F
  738.     (lambda (c-cleanup module-vars)
  739.       (continue
  740.        `(DYLAN::DYNAMIC-WIND (LAMBDA () 'DONE)
  741.                  (LAMBDA () ,c-protect)
  742.                  (LAMBDA () ,c-cleanup))
  743.        module-vars))))))
  744.  
  745. (define (compile-WHEN-form
  746.      forms module-vars bound-vars really-compile
  747.      multiple-values? continue)
  748.   (must-be-list-of-at-least-length forms 1 "WHEN: bad syntax")
  749.   (compile-forms forms module-vars bound-vars really-compile
  750.          (if (null? (cdr forms)) #F multiple-values?)
  751.     (lambda (forms module-vars)
  752.       (continue
  753.        `(IF ,(car forms)
  754.         (BEGIN ,@(if (null? (cdr forms)) (list #F) (cdr forms)))
  755.         #F)
  756.        module-vars))))
  757.  
  758. (define (compile-WHILE-form
  759.      forms module-vars bound-vars really-compile
  760.      multiple-values? continue)
  761.   (must-be-list-of-at-least-length forms 1 "UNTIL: bad syntax")
  762.   (compile-forms forms module-vars bound-vars really-compile
  763.          (if (null? (cdr forms)) #F multiple-values?)
  764.     (lambda (forms module-vars)
  765.       (continue
  766.        `(DYLAN::WHILE (LAMBDA () ,(car forms))
  767.               (LAMBDA () ,@(if (null? (cdr forms))
  768.                        (list #F)
  769.                        (cdr forms))))
  770.        module-vars))))
  771.